Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/rptwrite.fr_/rptwrite.fr

Text File | 1995-07-20 | 13KB | 484 lines

VERSION 4.00
Begin VB.Form frmReportWriter
   BackColor       =   &H00C0C0C0&
   Caption         =   "Visual Report Writer"
   ClientHeight    =   5190
   ClientLeft      =   1110
   ClientTop       =   1530
   ClientWidth     =   7320
   Height          =   5685
   Left            =   1005
   LinkTopic       =   "Form1"
   ScaleHeight     =   5190
   ScaleWidth      =   7320
   Top             =   1140
   Width           =   7530
   Begin VB.PictureBox picHead
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   300
      Left            =   0
      ScaleHeight     =   300
      ScaleWidth      =   7320
      TabIndex        =   5
      Top             =   0
      Width           =   7320
      Begin VB.CommandButton cmdSave
         Caption         =   "&Save File"
         Height          =   252
         Left            =   5160
         TabIndex        =   2
         Top             =   0
         Width           =   972
      End
      Begin VB.CommandButton cmdQuit
         Caption         =   "&Quit"
         Height          =   252
         Left            =   6240
         TabIndex        =   3
         Top             =   0
         Width           =   972
      End
      Begin VB.CommandButton cmdReport
         Caption         =   "&Create Report"
         Default         =   -1  'True
         Height          =   252
         Left            =   120
         TabIndex        =   0
         Top             =   0
         Width           =   1212
      End
      Begin VB.Label lblStatus
         Alignment       =   2  'Center
         BorderStyle     =   1  'Fixed Single
         Height          =   252
         Left            =   1440
         TabIndex        =   1
         Top             =   24
         Width           =   3612
      End
   End
   Begin MSComDlg.CommonDialog cdBiblio
      Left            =   6240
      Top             =   0
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
      DefaultExt      =   "MDB"
      DialogTitle     =   "BIBLIO.MDB Location"
      FileName        =   "biblio.mdb"
      Filter          =   "BIBLIO Database (biblio.mdb)|biblio.mdb|All Files (*.*)|*.*|"
   End
   Begin VB.OLE oleWord
      Height          =   4452
      Left            =   120
      OLETypeAllowed  =   1  'Embedded
      TabIndex        =   4
      Top             =   600
      Width           =   7092
   End
   Begin VB.Menu mnuFratsaBlatz
      Caption         =   "&FratsaBlatz"
      NegotiatePosition=   1  'Left
      Visible         =   0   'False
   End
End
Attribute VB_Name = "frmReportWriter"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Dim objWord As Object
Dim pAppPath As String

Dim ColumnTabs(4) As String
Dim ColumnHeaders(5) As String
Dim ColumnWidths(5) As String

'OLE Control Constants
Const OLE_Activate As Integer = 7
Const OLE_Deactivate As Integer = 9

Sub PrintColHeaders(Tabs() As String, ColHeaders() As String)
    Dim i As Integer

    'Assumes cursor is at the beginning of the proper location
    objWord.InsertPara
    objWord.LineUp
    objWord.FormatParagraph Before:="12 pt", _
        After:="6 pt"
    For i = 0 To UBound(Tabs)
        objWord.FormatTabs Position:=Tabs(i) + Chr$(34), _
            Align:=0
    Next
    For i = 0 To UBound(ColHeaders) - 1
        objWord.INSERT ColHeaders(i) + Chr$(9)
    Next

    With objWord
        .StartOfLine
        .SelectCurSentence
        .CharRight 1, 1
        .FormatFont Points:="12", _
            Font:="Times New Roman", _
            Bold:=1
        .FormatBordersAndShading ApplyTo:=0, _
            BottomBorder:=2
        .LineDown
    End With
End Sub

Sub PrintFooter(Company As String)

    'Insert the report footer
    objWord.ViewFooter
    objWord.FormatTabs ClearAll:=1
    objWord.FormatTabs Position:="7.0" + Chr$(34), _
        DefTabs:="0.5" + Chr$(34), _
        Align:=2, _
        Leader:=0
    objWord.StartOfLine
    objWord.INSERT Company + Chr$(9) + "Page "
    objWord.InsertPageField
    objWord.SelectCurSentence
    objWord.FormatFont Points:="12", _
        Font:="Times New Roman", _
        Bold:=1

    objWord.ViewFooter
End Sub

Sub PrintReportTitle(Title As String)
    With objWord
        .StartOfDocument
        .InsertPara
        .StartOfDocument
        .INSERT Title
        .StartOfLine
        .SelectCurSentence
        .FormatFont Points:="18", _
            Font:="Times New Roman", _
            Bold:=1, _
            Italic:=1
        .CenterPara

        .FormatBordersAndShading ApplyTo:=0, _
            Shadow:=0

        'Leave the cursor on the following line
        .LineDown
    End With
End Sub

Sub SetColumnWidths()
    Dim i As Integer
    For i = LBound(ColumnTabs) To UBound(ColumnTabs)
        If i Then
            ColumnWidths(i) = Str$(Val(ColumnTabs(i)) - Val(ColumnTabs(i - 1)))
        Else
            ColumnWidths(i) = ColumnTabs(i)
        End If
    Next
End Sub

Sub Status(txtCaption)
    lblStatus.Caption = txtCaption
    lblStatus.Refresh
End Sub

Private Sub cmdQuit_Click()
    Status "Ending application"
    End
End Sub

Private Sub cmdReport_Click()
    Dim rptDB As DATABASE
    Dim rptRS As Recordset
    Dim Title As String
    Dim i As Integer
    Dim insertText As String
    Dim strFileName As String

    Status "Opening database table"

    'If this is the first time running, put the Visual Basic
    'path in the common dialog as the initial directory
    If cdBiblio.InitDir = "" Then
        cdBiblio.InitDir = "c:\vb"
        cdBiblio.filename = cdBiblio.InitDir & "\" & cdBiblio.filename
    End If

    cdBiblio.InitDir = App.Path
    On Error GoTo userCanceled
    Do While Dir(cdBiblio.filename) = ""
        cdBiblio.ShowOpen
    Loop
    On Error GoTo 0

    Set rptDB = OpenDatabase(cdBiblio.filename)
    Set rptRS = rptDB.OpenRecordset("All Titles")

    Status "Creating a new Word document"

    objWord.FileNew
    Title = "Bibliography Database"

    Status "Inserting header and footer information"
    PrintHeader Title, ColumnTabs(), ColumnHeaders()
    PrintFooter "Enlighthened Software, Inc."
    PrintReportTitle Title
    PrintColHeaders ColumnTabs(), ColumnHeaders()

    'Start printing the report
    Status "Adding data to report"
    objWord.TableInsertTable NumColumns:=5, _
        NumRows:=2, _
        InitialColWidth:="2 in"
    For i = 0 To 4
        With objWord
            .TableSelectColumn
            .TableColumnWidth ColumnWidth:=ColumnWidths(i)
            .NextCell
            .NextCell
        End With
    Next

    'Format the paragraph height
    objWord.TableSelectTable
    objWord.FormatParagraph Before:="6 pt"

    'Select the first cell in the table
    'objWord.TableSelectColumn
    objWord.NextCell

    'On error resume is a handy way to ignore nulls
    On Error Resume Next
    Do While Not rptRS.EOF
        With objWord
            insertText = rptRS.Fields("Title")
            .INSERT insertText
            .NextCell
            insertText = rptRS("ISBN")
            .INSERT insertText
            .NextCell
            insertText = rptRS("Author")
            .INSERT insertText
            .NextCell
            insertText = rptRS("Year Published")
            .INSERT insertText
            .NextCell
            insertText = rptRS("Company Name")
            .INSERT insertText
            .NextCell
            .TableInsertRow
        End With
        rptRS.MoveNext
    Loop
    On Error GoTo 0

    'Save the Word document
    objWord.ToolsOptionsSave SummaryPrompt:=0

    strFileName = App.Path & "\TempRpt.doc"
    'Word won't let us save a file over an existing document
    If Len(Dir(strFileName)) Then
        Kill strFileName
    End If
    objWord.FileSaveAs Name:=strFileName

    oleWord.CreateEmbed strFileName
    oleWord.Refresh

    Status "Report complete"

OuttaHere:
    Set rptDB = Nothing
    Set rptRS = Nothing
    Exit Sub

userCanceled:
    Status "Report canceled by user"
    Resume OuttaHere

End Sub


Sub PrintHeader(Title As String, Tabs() As String, ColHeaders() As String)
    Dim i As Integer

    With objWord
        'For now, set DifferentFirstPage to no
        .FilePageSetup TopMargin:="0.8" + Chr$(34), _
            BottomMargin:="0.8" + Chr$(34), _
            LeftMargin:="0.75" + Chr$(34), _
            RightMargin:="0.75" + Chr$(34), _
            ApplyPropsTo:=4, _
            DifferentFirstPage:=0
    End With

    'Insert the report header
    With objWord
        .ViewHeader
        .FormatTabs ClearAll:=1
        .FormatTabs Position:="7.0" + Chr$(34), _
            DefTabs:="0.5" + Chr$(34), _
            Align:=2
        .StartOfLine
        .SelectCurSentence
        .CharRight 1, 1
        .FormatFont Points:="12", _
            Font:="Times New Roman", _
            Bold:=1
        .StartOfLine
        .INSERT Title + Chr$(9)
        .InsertDateTime DateTimePic:="d' 'MMMM', 'yyyy", _
            InsertAsField:=0
        .InsertPara
        .InsertPara
    End With

    PrintColHeaders Tabs(), ColHeaders()

    objWord.ViewHeader   'Closes if it is open

    'Now set DifferentFirstPage
    objWord.FilePageSetup DifferentFirstPage:=1

End Sub




Private Sub cmdSave_Click()
    WordFileSave oleWord
End Sub


Sub WordFileSave(OLECtrl As Control)
    Dim WordObj As Object
    Dim WBasic As Object

    'Activate the OLE control, and copy to the Clipboard
    Status "Copying report to clipboard"
    oleWord.Action = OLE_Activate
    Set WBasic = CreateObject("Word.Basic")
    WBasic.EditSelectAll
    WBasic.EditCopy
    oleWord.Action = OLE_Deactivate

    'Set up the properties for the FileSave common dialog
    'and open to get the file save name
    Status "Setting up file save"
    cdBiblio.Filter = "Word Document (*.Doc)|*.doc"
    cdBiblio.DefaultExt = "doc"
    cdBiblio.filename = oleWord.SourceDoc
    On Error GoTo FileSaveCancel:
    cdBiblio.Action = 2

    'Check to see if the file exists - if it does, need new
    'name for the file - Word can't overwrite an existing file
    Do While Len(Dir$(cdBiblio.filename))
        MsgBox "Please choose a new name for the file."
        cdBiblio.Action = 2
    Loop
    On Error GoTo 0

    'Use a new instance of Word to save the document
    Status "Saving Word document"
    Set WBasic = Nothing
    Set WordObj = GetObject("", "Word.Document.6")
    Set WBasic = WordObj.Application.WordBasic
    WBasic.FileNew
    WBasic.EditPaste
    WBasic.FileSaveAs cdBiblio.filename
    WBasic.FileClose

    'Release the objects created in this procedure
    Status "Report saved"
    Set WBasic = Nothing
    Set WordObj = Nothing

LeaveSub:
    Exit Sub

FileSaveCancel:
    Select Case Err.Number
        Case 32755
            'User pressed cancel
            Status "Save canceled by user"
            Resume LeaveSub
        Case Else
            Error Err.Number
    End Select
End Sub

Private Sub Form_Load()
    Status "Creating a Word object"
    Me.Show
    Me.Refresh

    'Create a Microsoft Word object
    Set objWord = GetObject("", "Word.Basic")
    objWord.AppMinimize ("Microsoft Word")

    cmdReport.Enabled = True
    cmdQuit.Enabled = True

    'Set up standard layout information
    ColumnTabs(0) = "2.0"
    ColumnTabs(1) = "3.25"
    ColumnTabs(2) = "4.75"
    ColumnTabs(3) = "5.25"
    ColumnTabs(4) = "7.0"

    ColumnHeaders(0) = "Title"
    ColumnHeaders(1) = "ISBN"
    ColumnHeaders(2) = "Author"
    ColumnHeaders(3) = "Year"
    ColumnHeaders(4) = "Publisher"

    SetColumnWidths

    Status "Click on Create Report to create the report."
End Sub



Private Sub Form_Resize()
    Dim border As Integer
    Dim winWidth As Integer

    border = picHead.Height
    winWidth = Me.ScaleWidth

    cmdReport.Height = border
    cmdQuit.Height = border
    cmdSave.Height = border

    cmdQuit.Left = winWidth - cmdQuit.Width - cmdReport.Left
    cmdSave.Left = cmdQuit.Left - cmdReport.Left - cmdSave.Width
    lblStatus.Width = cmdSave.Left - lblStatus.Left - cmdReport.Left
    lblStatus.TOP = (picHead.Height - lblStatus.Height) / 2

    oleWord.Left = border
    oleWord.Width = Me.ScaleWidth - 2 * border
    oleWord.Height = Me.ScaleHeight - oleWord.TOP - border

End Sub


Private Sub Form_Unload(Cancel As Integer)
    'Shut down Word
    Set objWord = Nothing
End Sub